COMMENT ⊗   VALID 00005 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	ENTRY
C00004 00003	! 	ttysave,file_string
C00006 00004	! input/output:      altf,altrans,alframe,aldec,al_subtree,alid
C00014 00005	! i/o: writecode
C00016 ENDMK
C⊗;
ENTRY;
BEGIN "OUTPUT"

DEFINE $OUTPUT=TRUE;

REQUIRE "HEADER.SAI" SOURCE_FILE;

EXTERNAL INTEGER PROCEDURE UGETF(INTEGER CHAN);
EXTERNAL INTEGER PROCEDURE UGET(INTEGER CHAN);

RCLASS FILE_LIST(STRING FILE; RPTR(FILE_LIST)NEXT);
RPTR(FILE_LIST)FLIST;

STRING PROCEDURE STD_FILENAME(STRING S);
BEGIN
	INTEGER EXTEN,PPN,F;
	F←CVFIL(S,EXTEN,PPN);
	RETURN(CVXSTR(F)&"."&CVXSTR(EXTEN)[1 TO 3]&"["&CVXSTR(PPN)[1 TO 3]&","
			&CVXSTR(PPN)[4 TO 6]&"]");
END;

BOOLEAN PROCEDURE USED_BEFORE(STRING FILE);
BEGIN
	RPTR(FILE_LIST)PTR; STRING S;
	PTR←FLIST; S←STD_FILENAME(FILE);
	WHILE PTR DO
		IF EQU(S,FILE_LIST:FILE[PTR])
		THEN RETURN(TRUE) ELSE PTR←FILE_LIST:NEXT[PTR];
	RETURN(FALSE);
END;


PROCEDURE ADD_USED_LIST(STRING FILE);
BEGIN
	RPTR(FILE_LIST)PTR; STRING S;
	PTR←FLIST; S←STD_FILENAME(FILE);
	WHILE PTR DO
		IF EQU(S,FILE_LIST:FILE[PTR])
		THEN RETURN ELSE PTR←FILE_LIST:NEXT[PTR];
	PTR←NEW_RECORD(FILE_LIST);
	FILE_LIST:FILE[PTR]←S;
	FILE_LIST:NEXT[PTR]←FLIST;
	FLIST←PTR;
END;
! 	ttysave,file_string;
INTERNAL PROCEDURE TTYSAVE(STRING FILE);
	BEGIN
	INTEGER OLD$TTYCH;
	OLD$TTYCH←$TTYCH;
	IF not $OUT THEN $TTYCH←ORAFILE(FILE)
	ELSE IF NOT EQU(STD_FILENAME(FILE),STD_FILENAME($TTYFL))
		THEN BEGIN
		    $TTYCH←ORAFILE(FILE);	! note if fails doesnt return ;
		    CRAFILE(OLD$TTYCH);
		    END;
	$TTYFL←FILE;
	$OUT←TRUE;
	$OULST←NULL;
	OUT($TTYCH,FF&"{ FILE being written by POINTY: "&DAT_STR&"}"&CRLF);
	END;

	! returns a string with the names of files used for output ;
INTERNAL STRING PROCEDURE FILE_STRING;
	BEGIN
	STRING TS; TS←NULL;
	IF $OUT THEN TS←"*"&$TTYFL;
	TS←CRLF&" "&$ALFL;
	RETURN(TS);
	END;

! input/output:      altf,altrans,alframe,aldec,al_subtree,alid;

PRELOAD_WITH "SCALAR ","VECTOR ","ROT ","TRANS ","FRAME ","EVENT ";
STRING ARRAY DTYPES[#SC:#EV];

STRING PROCEDURE DIM_AND_TYPE(RPTR(SYMBOL)SYM);
	BEGIN  STRING S; RPTR(SYMBOL)D; D←CHCKDIM(SYMBOL:DIMENS[SYM]); S←NULL;
	CASE SYMBOL:TYPE[SYM] OF
	    BEGIN
	    [#SC] [#VT]
		IF NOT CHECK_DIMENS(SYMBOL:OBJECT[D],NIL_DIMENS) THEN
			S←SYMBOL:PNAME[D]&" ";
	    [#RT] [#EV];
	    [#TR][#FR]
		IF NOT CHECK_DIMENS(SYMBOL:OBJECT[D],DISTANCE_DIMENS) THEN
			S←SYMBOL:PNAME[D]&" ";
	    ELSE ERROR("ERROR IN DIM_AND_TYPE PROCEDURE - SHOULD NOT HAPPEN")
	    END;
	RETURN(S&DTYPES[SYMBOL:TYPE[SYM]]);
	END;

	! returns frame declaration and assignment
	  of affixment for the frame pointed by nd. If the frame is affixed 
	  independently an assignment instruction is generated, otherwhise an
	  affix instruction, with the correct type of affixment is produced;

STRING PROCEDURE ALDEC(RPTR(FRAME) ND);
	BEGIN
	STRING NAME,DS,FS;
 	NAME←FRAME:PNAME[ND];				! frame pname;
	IF SYMBOL:ACCESS[FRAME:SYM[ND]]≠#ARRAY_ELEMENT
		THEN DS←DIM_AND_TYPE(FRAME:SYM[ND])&NAME&";"&CRLF
		ELSE DS←NULL;
 	IF FRAME:HOWLINKED[ND]=#INDLK
	   THEN FS←NAME&" ← "&CVSYM(FRAME:SYM[ND],FILE_D)&";"&DLF
	   ELSE BEGIN
        	FS←"AFFIX "&NAME&" TO "&FRAME:PNAME[FRAME:DAD[ND]]&" AT"
			&CRLF&$BLANK[1 TO 6]&"TRANS"&CVSYM(FRAME:SYM[ND],FILE_D)[6 TO ∞];
		IF FRAME:HOWLINKED[ND]=#NRGLK
		   THEN FS←FS&" NONRIGIDLY;"&DLF
		   ELSE FS←FS&" RIGIDLY;"&DLF;
		END;
	RETURN(DS&FS);
	END;

STRING PROCEDURE MC_OUT(RPTR(SYMBOL) EEE);
	BEGIN 
	STRING MS;
	MS←"DEFINE "&MACRO:HEAD[SYMBOL:OBJECT[EEE]]&" = "&CVSYM(EEE)&";"&DLF;
	RETURN(MS);
	END;

STRING PROCEDURE PR_OUT(RPTR(SYMBOL) EEE);
	BEGIN
	STRING PS;
	PS←CVSYM(EEE)&DLF;
	RETURN(PS);
	END;

PRELOAD_WITH "BPARK","YPARK","GPARK","RPARK","BARM","YARM","GARM","RARM","BGRASP";
STRING ARRAY NOOUT[1:9];

BOOLEAN PROCEDURE SHOULDPRINT(RPTR(FRAME)ND);
	BEGIN
	STRING S; INTEGER I;
	IF ND=F_WRLD THEN RETURN(FALSE);
	S←FRAME:PNAME[ND];
	FOR I←1 STEP 1 UNTIL 9 DO IF EQU(S,NOOUT[I]) THEN RETURN(FALSE);
	RETURN(TRUE);
	END;

STRING RECURSIVE PROCEDURE FR_OUT(RPTR(FRAME) ND);
	BEGIN
	RPTR(FRAME) SN; STRING S,RSTRING;
	RSTRING←NULL;
	IF SHOULDPRINT(ND) THEN RSTRING←ALDEC(ND);
	SN←FRAME:SON[ND];
	WHILE SN≠NULL_RECORD 
	     DO	BEGIN
		RSTRING←RSTRING&FR_OUT(SN);
	 	SN←FRAME:EBRO[SN];
		END;
	RETURN(RSTRING);
	END;

STRING PROCEDURE EL_OUT(RPTR(SYMBOL)ADDR);
	BEGIN
	STRING DS,VS;
	CASE SYMBOL:ACCESS[ADDR] OF BEGIN
	[#SIMPLE] BEGIN
		DS←DIM_AND_TYPE(ADDR)&" "&SYMBOL:PNAME[ADDR]&";"&CRLF;
		IF SYMBOL:TYPE[ADDR]≠#EV THEN
		   VS←SYMBOL:PNAME[ADDR]&" ← "& CVSYM(ADDR,FILE_D)&";"&CRLF;
		RETURN(DS&VS&CRLF);
		END;
	[#PROCEDURE] RETURN(PR_OUT(ADDR))
		END;
	END;

STRING PROCEDURE ARR_OUT(RPTR(SYMBOL)ADDR);
	BEGIN
	RPTR(ARRAYREC) ARRREC;
	STRING DS,VS;
	INTEGER I,#DIM;
	$EVLARR(ADDR);
	DS←DIM_AND_TYPE(ADDR)&"ARRAY "&SYMBOL:PNAME[ADDR]&"[";
	ARRREC←SYMBOL:OBJECT[ADDR];
	FOR I←1 STEP 1 UNTIL (#DIM←ARRAYREC:#DIM[ARRREC]) DO
		DS←DS&CVS(ARRAYREC:LB[ARRREC][I])&":"
			&CVS(ARRAYREC:UB[ARRREC][I])&",";
	DS←DS[1 TO INF - 1]&"];"&CRLF;
	VS←NULL;
	FOR I←1 STEP 1 UNTIL ARRAYREC:#EL[ARRREC] DO
		VS←VS&SYMBOL:PNAME[ARRAYREC:PTR[ARRREC][I]]&"←"
			&CVSYM(ARRAYREC:PTR[ARRREC][I],FILE_D)
			&";"&CRLF;
	RETURN(DS&VS&CRLF);
	END;

STRING PROCEDURE DM_OUT(RPTR(SYMBOL)SYM);
	BEGIN
	STRING S;
	RPTR(DIMENS)D; D←SYMBOL:OBJECT[SYM];
	S←NULL;
	S←S&DSTRING(DIMENS:DISTANCE[D],"*DISTANCE","*INV(DISTANCE)");
	S←S&DSTRING(DIMENS:TIME[D],"*TIME","*INV(TIME)");
	S←S&DSTRING(DIMENS:FORCE[D],"*FORCE","*INV(FORCE)");
	S←S&DSTRING(DIMENS:ANGLE[D],"*ANGLE","*INV(ANGLE)");
	IF EQU(S,NULL) THEN S←" DIMENSIONLESS";
	RETURN("DIMENSION "&SYMBOL:PNAME[SYM]&" = "&S[2 TO ∞]);
	END;

STRING PROCEDURE ST_OUT(INTEGER TYPE);
	BEGIN "U" INTEGER I;
	STRING S; S←NULL;
	CASE TYPE OF
	    BEGIN "CASE"
		  [#SC] [#VT][#RT][#TR][#EV]
			FOR I←OFFSET[RES_OFFSET,TYPE]+1 STEP 1 UNTIL
				$ENTRY[TYPE] DO
				IF SYMBOL:ACCESS[$YMPTR(TYPE,I)]=#ARRAY
				    THEN S←S&ARR_OUT($YMPTR(TYPE,I))
				    ELSE S←S&EL_OUT($YMPTR(TYPE,I));
		  [#FR] BEGIN
			FOR I←OFFSET[RES_OFFSET,#FR]+1 STEP 1 UNTIL $ENTRY[#FR] DO
				IF SYMBOL:ACCESS[$YMPTR(#FR,I)]=#PROCEDURE
				    THEN S←S&PR_OUT($YMPTR(#FR,I));
			S←S&FR_OUT(SYMBOL:OBJECT[WORLD]);
			END;
		  [#PR] FOR I←OFFSET[RES_OFFSET,TYPE]+1 STEP 1 UNTIL $ENTRY[TYPE] DO
				S←S&PR_OUT($YMPTR(TYPE,I));
		  [#MC] FOR I←OFFSET[RES_OFFSET,TYPE]+1 STEP 1 UNTIL $ENTRY[TYPE] DO
				S←S&MC_OUT($YMPTR(TYPE,I));
		  [#DM] FOR I←OFFSET[RES_OFFSET,TYPE]+1 STEP 1 UNTIL $ENTRY[TYPE] DO
				S←S&DM_OUT($YMPTR(TYPE,I))
		END "CASE";
	RETURN(S);
	END "U";
! i/o: writecode;

INTERNAL PROCEDURE WRITECODE(STRING FILE;RPTR(SYMBOL) ELEMENT);
	BEGIN
	STRING DATA_STRING,DSTRING;
	INTEGER I;
	DATA_STRING←NULL;
	IF ELEMENT=NULL_RECORD
	THEN FOR I←#DM,#SC,#VT,#RT,#TR,#FR,#EV,#MC,#PR DO
		 DATA_STRING←DATA_STRING&ST_OUT(I)
	ELSE IF SYMBOL:ACCESS[ELEMENT]=#ARRAY THEN
		DATA_STRING←ARR_OUT(ELEMENT)
	ELSE CASE SYMBOL:TYPE[ELEMENT] OF
	     BEGIN
		[#SC][#VT][#RT][#TR][#EV]
			DATA_STRING←EL_OUT(ELEMENT);
		[#FR] DATA_STRING←IF SYMBOL:ACCESS[ELEMENT]=#SIMPLE
					THEN FR_OUT(SYMBOL:OBJECT[ELEMENT])
					ELSE PR_OUT(ELEMENT);
		[#MC] DATA_STRING←MC_OUT(ELEMENT);
		[#PR] DATA_STRING←PR_OUT(ELEMENT);
		[#DM] DATA_STRING←DM_OUT(ELEMENT)
	     END;
	DSTRING←"{FILE being written by POINTY on "&DAT_STR&"}"
			&CRLF&DATA_STRING&CRLF;
	IF NOT USED_BEFORE(FILE) THEN DSTRING←FF&DSTRING;
	ADDFILE(FILE,DSTRING);
	ADD_USED_LIST(FILE); $ALFL←FILE;
	END;
END "OUTPUT";